unit uSBDUnit_TestSuiteNodeImpl;
interface
uses uSBDUnit_TestNodeImpl, uSBDUnit_TestNode_InternalSupport, uSBDUnit_Model,
     Classes, uSBDUnit_Types, uSBD_BaseTypes, uSBD_ServiceProvider;

type

TTestSuiteDomicile = record
  SuiteClass: TClass;
  SuiteObject: TObject;
  TestSuite: ITestSuite;
  doDestroy: boolean;
  FServiceProvider: IServiceProvider;

  function    CanCreate( BaseClass: TClass): boolean;
  constructor Create( BaseClass: TClass);
  function    isValid: boolean;
  procedure   Free;
  procedure   PowerUp;
  procedure   PowerDown;
  end;

TTestSuiteNode = class sealed( TTestNodeNonLeaf, ITestSuiteNodeEx)
  private
    FDom: TTestSuiteDomicile;

    procedure SetSuiteClass( Cls: TClass);
    procedure PowerDownSuite;
    function  GetSuite: ITestSuite;
    function  SuiteObject: TObject;
    function  SuiteClass: TClass;
    function  AddTestCaseChild: ITestCaseEx;

  protected
    function  ITestSuiteNodeEx.GetExecResult = GetExecResult_Overall;
    procedure Clear;                                 override;
    procedure ShutDown;                              override;
    class function  ExceptionClass: TSBDUnit_ExceptionClass;  override;

  public
    [Configuration('nkTestSuite')] constructor ServiceModeCreate; override;
  end;

TSBDUnit_TestSuiteException = class( TSBDUnit_Exception) end;



TGroupNode = class sealed( TTestNodeNonLeaf, ITestGroupEx)
  public
    [Configuration('nkTestGroup')] constructor ServiceModeCreate; override;
  end;

TRootNode = class sealed( TTestNodeNonLeaf, ITestNodeRootEx)
  public
    [Configuration('nkRoot')] constructor ServiceModeCreate; override;
  end;

procedure RegisterServices( const Registrar: IServiceProvider);
// ^-- Registers (ITestNode,'nkTestSuite') & (ITestNode,'nkTestGroup')

implementation




uses SysUtils, Rtti, TypInfo;



type

ITestSuiteAdapter = interface
  ['{44E69E58-FFBC-4549-B15E-88CA3BB9776F}']
    procedure SetTestSuiteObj( InheritenceStyle_TestSuiteObj1: TTestSuite);
  end;

TTestSuiteAdapter = class( TSBD_RefCountedCommonBase, ITestSuite, ITestSuiteAdapter)
  private
    FInheritenceStyle_TestSuiteObj: TTestSuite;
    procedure SetHarness( const Harness1: ITestHarness);
    procedure Setup;
    procedure Teardown;
    procedure SetTestSuiteObj( InheritenceStyle_TestSuiteObj1: TTestSuite);

  public
    [Configuration('Adapter')] constructor ServiceModeCreate;
    destructor  Destroy; override;
  end;


procedure RegisterServices( const Registrar: IServiceProvider);
begin
Registrar.RegisterServiceClass( TTestSuiteNode   , ITestNode ).Free; // 'nkTestSuite'
Registrar.RegisterServiceClass( TGroupNode       , ITestNode).Free;  // 'nkTestGroup'
Registrar.RegisterServiceClass( TRootNode        , ITestNode).Free;  // 'nkRoot'
Registrar.RegisterServiceClass( TTestSuiteAdapter, ITestSuite).Free; // 'Adapter'
end;

{ TTestSuiteDomicile }

function TTestSuiteDomicile.CanCreate( BaseClass: TClass): boolean;
begin
result := assigned( BaseClass) and
  (BaseClass.InheritsFrom( TTestSuite) or Supports( BaseClass, ITestSuite))
end;

constructor TTestSuiteDomicile.Create( BaseClass: TClass);
begin
if not CanCreate( BaseClass) then
  raise Exception.Create('Wrong base class for a test suite.');
SuiteClass  := BaseClass;
SuiteObject := nil;
TestSuite   := nil;
doDestroy   := False
end;

procedure TTestSuiteDomicile.Free;
begin
PowerDown
end;

function TTestSuiteDomicile.isValid: boolean;
var
  Context: TRttiContext;
  M: TRttiMethod;
  A: TCustomAttribute;
  CountTestCaseAttribs: integer;
  s: string;
begin
Context := TRttiContext.Create;
CountTestCaseAttribs := 0;
for M in Context.GetType( SuiteClass).GetDeclaredMethods do
  if (Length( M.GetParameters) = 0) and (M.MethodKind = mkProcedure) then
    begin
    s := M.Name;
    if SameText( s, 'Setup') or SameText( s, 'Teardown') then continue;
    if M.Visibility = mvPublished then
      Inc( CountTestCaseAttribs);
    for A in M.GetAttributes do
      if A.InheritsFrom( TestCase) then
        Inc( CountTestCaseAttribs)
    end;
Context.Free;
result := CountTestCaseAttribs > 0
// Assume already tested for:
//  (SuiteObject is TTestSuite) or Supports( SuiteObject, ITestSuite)
end;

procedure TTestSuiteDomicile.PowerDown;
begin
if not assigned( TestSuite) then exit;
if assigned( SuiteObject) then
  SuiteObject.Harness := nil;
TestSuite := nil;
if doDestroy then
  SuiteObject.Free;
SuiteObject := nil
end;

type
  TProtectedAccess_Persistent = class( TPersistent) end;
procedure TTestSuiteDomicile.PowerUp;
type
  TTestSuiteClass = class of TTestSuite;
var
  Adapter: ITestSuiteAdapter;
  Rtti: TRttiContext;
  SType: TRttiType;
  A: TCustomAttribute;
  M: TRttiMethod;
begin
if assigned( TestSuite) then exit;
if SuiteClass.InheritsFrom( TTestSuite) then
    begin
    SuiteObject := TTestSuiteClass( SuiteClass).Create;
    FServiceProvider.Acquire( nil, ITestSuite, TestSuite, 'Adapter');
    if Supports( TestSuite, ITestSuiteAdapter, Adapter) then
      Adapter.SetTestSuiteObj( TTestSuite( SuiteObject));
    doDestroy := False
    end
  else if Supports( SuiteClass, ITestSuite) then
    begin
    Rtti.Create;
    SType := Rtti.GetType( SuiteClass);
    for M in SType.GetDeclaredMethods do
      begin
      if (M.MethodKind <> mkConstructor) or (Length( M.GetParameters) <> 0) then continue;
      for A in M.GetAttributes do
        begin
        if not (A is SuiteConstructor) then continue;
        SuiteObject := M.Invoke( SuiteClass, []).AsObject;
        break
        end;
      if assigned( SuiteObject) then break
      end;
    Rtti.Free;
    if not assigned( SuiteObject) then
      SuiteObject := TClass( SuiteClass).Create;
    doDestroy :=  (not Supports( SuiteObject, ITestSuite, TestSuite))  or

                (((TestSuite._AddRef + TestSuite._Release) = -2) and
                 ( (not (SuiteObject is TPersistent)) or
                   (TProtectedAccess_Persistent( SuiteObject).GetOwner = nil) ));
    if not assigned( TestSuite) then
      raise TSBDUnit_Exception.CreateFmt( SuiteClass, 'Could not create implementing instance of class %s.', [SuiteClass.ClassName])
    end
  else if assigned( SuiteClass) then
    raise TSBDUnit_Exception.CreateFmt( SuiteClass, 'Could not create instance of class %s.', [SuiteClass.ClassName])
  else
    raise TSBDUnit_Exception.Create( nil, 'TTestSuiteDomicile.PowerUp - no suite class.')
end;






{ TTestSuiteNode }

function TTestSuiteNode.AddTestCaseChild: ITestCaseEx;
begin
result := AddNewChild( nkTestCase) as ITestCaseEx
end;

procedure TTestSuiteNode.Clear;
begin
inherited;
PowerDownSuite
end;

class function TTestSuiteNode.ExceptionClass: TSBDUnit_ExceptionClass;
begin
result := TSBDUnit_TestSuiteException
end;

function TTestSuiteNode.GetSuite: ITestSuite;
begin
FDom.PowerUp;
result := FDom.TestSuite
end;

procedure TTestSuiteNode.PowerDownSuite;
begin
FDom.PowerDown
end;

constructor TTestSuiteNode.ServiceModeCreate;
begin
FKind := nkTestSuite;
inherited ServiceModeCreate
end;

procedure TTestSuiteNode.SetSuiteClass( Cls: TClass);
var
  Context: TRttiContext;
  M: TRttiMethod;
  A: TCustomAttribute;
  CountTestCaseAttribs: integer;
  s: string;
  MethodIndex: integer;
  Addend: ITestNode;
begin
FDom.SuiteClass := Cls;
FDom.FServiceProvider := FServiceProvider;
Context := TRttiContext.Create;
MethodIndex := 0;
for M in Context.GetType( FDom.SuiteClass).GetDeclaredMethods do
  if (Length( M.GetParameters) = 0) and (M.MethodKind = mkProcedure) then
    begin
    s := M.Name;
    if (not SameText( s, 'Setup')) and (not SameText( s, 'Teardown')) then
      begin
      CountTestCaseAttribs := 0;
      if M.Visibility = mvPublished then
        Inc( CountTestCaseAttribs);
      for A in M.GetAttributes do
        if A.InheritsFrom( TestCase) then
          Inc( CountTestCaseAttribs);
      if CountTestCaseAttribs <> 0 then
        AddTestCaseChild.SetMethodIndex( MethodIndex)
      end;
    Inc( MethodIndex)
    end;
Context.Free;
end;

procedure TTestSuiteNode.ShutDown;
begin
FDom.PowerDown;
FDom.FServiceProvider := nil;
inherited
end;

function TTestSuiteNode.SuiteClass: TClass;
begin
result := FDom.SuiteClass
end;

function TTestSuiteNode.SuiteObject: TObject;
begin
FDom.PowerUp;
result := FDom.SuiteObject
end;

{ TTestSuiteAdapter }


constructor TTestSuiteAdapter.ServiceModeCreate;
begin
end;

destructor TTestSuiteAdapter.Destroy;
begin
FInheritenceStyle_TestSuiteObj.Free;
inherited Destroy
end;

procedure TTestSuiteAdapter.SetHarness( const Harness1: ITestHarness);
begin
FInheritenceStyle_TestSuiteObj.Harness := Harness1
end;

procedure TTestSuiteAdapter.SetTestSuiteObj(
  InheritenceStyle_TestSuiteObj1: TTestSuite);
begin
FInheritenceStyle_TestSuiteObj := InheritenceStyle_TestSuiteObj1
end;

type TTestSuiteProtAccess = class( TTestSuite)
  end;


procedure TTestSuiteAdapter.Setup;
begin
TTestSuiteProtAccess( FInheritenceStyle_TestSuiteObj).Setup
end;

procedure TTestSuiteAdapter.Teardown;
begin
TTestSuiteProtAccess( FInheritenceStyle_TestSuiteObj).TearDown
end;

{ TGroupNode }

constructor TGroupNode.ServiceModeCreate;
begin
  FKind := nkTestGroup;
  inherited;
// FName ?
end;

{ TRootNode }

constructor TRootNode.ServiceModeCreate;
begin
  FKind := nkRoot;
  inherited;

end;

end.
